perm filename ITMSBX.F4[MSS,LCS]8 blob
sn#136231 filedate 1974-12-15 generic text, type T, neo UTF8
00100 C**** ITMSUB, BMS, METER, RNOTE , MAKNUM ********
00200 C ********** WHOLE & HALF RESTS, BEAMS ******
00300 SUBROUTINE ITMSUB
00400 IMPLICIT INTEGER(A-Q,S-Z)
00500 REAL DIS,PWDS,DISX,HGT,POS,CENTR,STFF,HGT1
00600 COMMON/STF/RSTFAC(-3/4),RSTJ3/MIN/MINI,RMINI
00700 COMMON R2,JA,CENTR,J2,RJQ(20),JQ(20)/BM/RA,RC,RJY
00800 COMMON/POSI/STFF(-3/4),JJ2,POS/PLTR/PLT,RHT,DIS
00900 COMMON/ALF/QQ(3),RST7,RST18,R2Q,JY,RD,RX,RW,RJX,RJ,L,K,
01000 1 RJA,DRJY,DISX,HGT,RZ,INP(53)
01100 EQUIVALENCE (J3,JQ(1)),(J4,JQ(2)),(J5,JQ(3)),(R5,RJQ(3))
01200 1,(R6,RJQ(4)),(J7,JQ(5)),(J8,JQ(6)),(J9,JQ(7)),(J10,JQ(8))
01300 1,(J11,JQ(9)),(J6,JQ(4)),(R9,RJQ(7)),(R8,RJQ(6))
01400 1 ,(R7,RJQ(5)),(R4,RJQ(2)),(R9,RJQ(7)),(R10,RJQ(8))
01500 DATA R14/14.54/,RTF/3.0/,RHGT/48.0/,R2HGT/96.0/,RBM/.83/
01510 C RTF COMPENSATES FOR BAD PLANNING.
01600 RST7=RSTJ3*7.
01700 RST18=RSTJ3*18.
01800 C TO COMPENSATE FOR NOTE #3 COMING AT POS=0
01900
02000 R2Q=R2
02100 JY=0
02200 IF(JA.EQ.9)GO TO 90
02300 IF(JA.EQ.10)GO TO 100
02400 C GO TO LINES, BEAMS, STAVES.
02500 C NEXT DRAWS STRAIGHT LINES
02600
02700 RD=R4*RST7
02800 RA=0
02900 C WHY "*RSTJ3"????
03000 RX=RTF+POS
03100 IF(J5.EQ.50)GO TO 300
03200 IF(R6.GT.0.OR.J7)GO TO 401
03300 C FOR BAR LINES
03400 JA=44
03500 C CODE # IS CHNGD SO BAR LINES WON'T AFFECT MAX. HGT.
03600 CC IF(J7)GO TO 407
03700 C ↑↑↑↑↑↑↑↑↑ FOR VERTICAL WIGGLE (P6=0, P7=-1)
03800 IF(J7.EQ.0)J7=(J4/100)*DIS
03900 RA=1
04000 IF(PLT.GE.0)GO TO 40
04100 J7=J7+1
04200 RA=1./DIS
04300 C BAR LINES PLOT AS DOUBLE THICKNESS
04400 40 RX=RTF*RSTJ3+POS
04500 L=MOD(J4,100)+J3-1
04600 C J4=401 MAKES 4X THICK BARLINE - ONE STAFF
04700 RY=STFF(L)+RTF+RSTFAC(L)*56.
04800 RW=RY
04900 RJX=R2Q
05000 42 CALL LINES(R2Q,RX,3)
05100 CC IF(J7.EQ.-2)GO TO 404
05200 C IF J7<0 THEN WIGGLEY LINES ARE MADE.
05300 RJ=-1.
05400 406 CALL LINES(RJX,RY,2)
05500 IF(J7.LE.0)RETURN
05600 C FOR 'HEAVY' LINE.
05700 RJX=RJX+RA
05800 CALL LINES(RJX,RY,2)
05900 J7=J7-1
06000 RY=RW
06100 IF(RJ)RY=RX
06200 RJ=-RJ
06300 GO TO 406
06400 43 IF(RA.GT.0)GO TO 403
06500 RETURN
06600 C HOV IS RA.NE.0?
06700 C DRAWS BAR LINES. J4>0 CAUSES FULL LINE.
06800 403 RA=RA-3.72
06900 R2Q=R2Q+22
07000 RJX=RJX+22
07100 C DO ABOVE NEED *RSTJ3? ************
07200 C **** BASED ON '596' ****
07300 GO TO 42
07400
07500 C FOR CRESC., DECRESC.
07600 300 RA=ABS(R7/2.0)*RST7
07700 C AMOUNT OF SPREAD
07800 RJ=R2Q
07900 RX=RX-RST18+RD
08000 IF(R8.NE.0)GO TO 302
08100 C JUMP TO MAKE BOX
08200 R6=RHORZ(R6)
08300 IF(R7)GO TO 301
08400 RJ=R6
08500 R6=R2Q
08600 301 CALL LINX(RJ,RX+RA,R6,RX)
08700 CALL LINES(RJ,RX-RA,2)
08800 C FOR CRESC, DECRESC: 4 POS1, STF, HGT, 50, POS1, +OR-N
08900 RETURN
09000
09100 302 R8=R8*RST7
09200 R9=R9*RST7
09300 IF(R9.EQ.0)R9=R8
09400 R2=R2Q-R8/2.
09500 RX=RX-R9/2.
09600 C DRAWS BOX, CENTER IS IN MIDDLE
09700 C 4,POS,STF,NT#,50,0,0,,SIZ1[BY NT#S],SIZ2
09800 CALL LINX(R2,RX,R2+R8,RX)
09900 CALL LINES(R2+R8,RX+R9,2)
10000 CALL LINES(R2,RX+R9,2)
10100 CALL LINES(R2,RX,2)
10200 RETURN
10300
10400 C DASHES
10500 401 POS=POS-RST18
10600 C********* 27/9/72 ******
10700 IF(J7.EQ.0)GO TO 407
10800 CC IF(J7)GO TO 421
10900 IF(J7)GO TO 407
11000 IF(R8.EQ.0)R8=.8
11100 C P8 CAN SET SIZE OF DASH
11200 RD=RD+POS
11300 IF(ABS(R6-R2).LT..01)GO TO 402
11400 C VERTICAL DASHES IF P6=P2
11500 R6=RHORZ(R6)
11600 R8=R8*5.96*RSTJ3
11700 420 CALL LINX(R2Q,RD,R2Q+R8,RD)
11800 R2Q=R2Q+R8+R8
11900 IF(R2Q.GE.R6)RETURN
12000 GO TO 420
12100
12200 CC IF(J7.GT.0)J7=0
12300 CC GO TO 407
12400 402 RA=POS+R5*RST7
12500 RJ=R8*RST7
12600 CC RX=RD+POS
12700 L=3
12800 K=2
12900 41 IF(RD.GT.RA)RETURN
13000 C DASHES MUST GO FROM BOTTOM TO TOP.
13100 CALL LINES(R2Q,RD,L)
13200 RD=RD+RJ
13300 CALL EXCH(K,L)
13400 GO TO 41
13500
13600 407 RX=RD+POS
13700 RY=R5*RST7+POS
13800 IF(J7.EQ.-1)GO TO 408
13900 C FOR 'TR' J7=-2, 'ARPEGG' J7=-1, STRAIGHT LINES J7=0
14000 RJX=IFIX(RHORZ(R6))
14100 IF(J7.EQ.0)GO TO 42
14200 4041 CALL NOZERO(R8)
14300 CALL LINES(R2Q,RX,3)
14400 C DRAWS STRAIGHT LINES. ETC.
14500 R9=R2Q
14600 RJ=RY
14700 RW=3.*RSTJ3*R8
14800 RA=RW*2.5
14900 C P8=HORZ. WIGGLE SIZE; P5=VERT.
15000 404 R9=R9+RA
15100 CALL LINES(R9,RJ,2)
15200 R9=R9+RW
15300 CALL LINES(R9,RJ,2)
15400 405 CALL EXCH(RX,RJ)
15500 IF(R9.LT.RJX)GO TO 404
15600 IF(J10.LE.0)RETURN
15700 POS=POS+1
15800 J10=J10-1
15900 GO TO 407
16000 C P10= + NUM OF THICKNESSES TO WIGGLE
16100
16200 408 IF(RX.GT.RY)CALL EXCH(RX,RY)
16300 CALL NOZERO(R9)
16400 RZ=R9*RSTJ3*5.96
16500 C USE P9 TO SET WIGGLE WIDTH. P8 TO SET HGT.
16800 CALL NOZERO(R8)
16900 CC RD=R8*RST7/3.
16950 RD=R8*RST7*.5
16960 CC RD=R8*RST7*.6
17000 CC RJ=RD*.66666
17050 RJ=RD
17100 IF(RD.LT.1.)RD=1.
17200 421 R9=RX
17300 RW=R2Q
17400 RA=RZ+R2Q
17500 CALL LINES(RW,R9,3)
17600 410 R9=R9+RJ
17700 CALL LINES(RA,R9,2)
17800 R9=R9+RD
17900 CALL LINES(RA,R9,2)
18000 CALL EXCH(RA,RW)
18100 IF(R9.LT.RY)GO TO 410
18200 IF(J10.LE.0)RETURN
18300 R2Q=R2Q+1
18400 J10=J10-1
18500 GO TO 421
18600 C VERTICAL WIGGLE P10=+ NUM OF THICKNESSES.
18700
18800
18900 C NEXT IS FOR BEAMS
19000 90 RMINI=RSTJ3
19100 RX=2.7*RSTJ3*5.96
19200 C******************************
19300 R6=RHORZ(R6)
19310 R9=RHORZ(R9)
19400 IF(J10.LT.10)GO TO 91
19500 C NEXT FOR INNER, PARTIAL BEAMS
19650 R8=RHORZ(R8)
19700 R10=AMOD(R10,10.)
19800 GO TO(2,3,4),J10/10
19900 2 R8=R9+RX
20000 GO TO 4
20100 3 R8=R9-RX
20300 C 10=SHORT PARTIAL LFT→RT., 20=RT.←LFT, 30=TO POS IN P8
20400 4 RH=R8
20500 C LEFT INNER POS.
20600 GO TO 1
20700 C******************************
20800 91 IF(J8.GE.0)GO TO 1
20900 92 R9=R2+RX
21000 IF(J8.LE.-20)R9=R6-RX
21100 192 J8=-J8
21200 IF(J10.EQ.0)J10=MOD(J8,10)
21300 J8=J8-J10
21400 IF(J10.EQ.0)J10=1
21500 R10=J10
21600 C IF P8 NEG, P9 IS AUTOMATIC, ALSO P10 IF NEEDED.
21700 1 IF(IABS(J4).LT.100)GO TO 97
21800 RMINI=.6*RSTJ3
21900 R5=AMOD(R5,100.0)
22000 C SPACE BETWEEN BEAMS
22100 97 RJ=RMINI*11.
22200 RW=RMINI*RHGT
22300 C DIST. UP OR DOWN FROM NOTE HEAD.
22400 RJA=R10*RJ
22500 C DISPLACEMENT
22600 CC RD=RHORZ(ABS(R9))
22700 RD=R9
22800 C POSITION 3
22900 RJX=CENTR-RW+RJA
23000 C FINAL HEIGHT
23100 CC?????? RX=MOD(J7,10)-MOD(J8,10)
23200 IF(J7)J7=-J7
23300 C NEG R7=TREMOLO
23400 RX=MOD(J7,10)
23500 JJ2=J7-20
23600 RA=R6
23700 C HORIZANTAL DIST.
23800 RJY=R5*RST7+POS-RST18-RW+RJA
23900 C************************
24000 RW=R14*RMINI
24100 RY=1.
24200 IF(J7.GE.20)GO TO 930
24300 C JUMP IF STEMS ARE DOWN
24400 RY=-RY
24500 C FOR THICKENING INCR.
24600 JJ2=J7-10
24700 RJ=-RJ
24800 CCAUG.7,73 RJA=RMINI*R2HGT-2.*RJA-3.
24900 CC RY=-3
25000 CC IF(RMINI.LT..65)RY=-1
25100 CC RJA=RMINI*R2HGT-2.*RJA+RY
25200 RJA=RMINI*R2HGT-2.*RJA
25300 RJX=RJX+RJA
25400 RJY=RJY+RJA
25500 R2Q=R2Q+RW
25600 C POSITION 1
25700 RA=RA+RW
25800 C POSITION 2
25900 RD=RD+RW
26000 C******************************
26100 RH=RH+RW
26200 930 IF(R7.GE.0)GO TO 98
26300 R2Q=R2Q-13.*RSTJ3
26400 C SHIFTS HEAD OF TREM. TO LEFT.
26500 RA=R2Q+27.*RSTJ3
26600 98 RSTJ3=RSTJ3*RBM
26700 C RBM BRINGS LINES OF BEAMS CLOSER TOGETHER. (=.83)
26800 93 IF(JJ2.GT.RX)GO TO 94
26900 IF(J10.GE.10)GO TO 7
27000 C**********************
27100 IF(J8.EQ.0)GO TO 94
27200 R3=RW
27300 C******************************
27400 CC IF(R9.EQ.0)GO TO 292
27500 IF(J9.EQ.0)GO TO 292
27600 IF(J8.GE.20)GO TO 193
27700 C******************************
27800 CC IF(J9.GT.0)GO TO 293
27900 293 RX=R2Q-RD
28000 GO TO 194
28100 C******************************
28200 7 RHX=RH-R2Q
28300 CC R3=RX-R2Q
28400 R3=RD-R2Q
28500 GO TO 292
28600 193 RX=RD-RA
28700 194 R3=ABS(RX)
28800 292 DISX=ABS(R2Q-RA)
28900 HGT=RJX-RJY
29000 IF(J10.GE.10)HGT1=HGT*RHX/DISX
29100 C**********************
29200 R3=R3/DISX
29300 195 HGT=HGT*R3
29400 196 L=J8/10
29500 J8=0
29600 IF(J10.GE.10)GO TO 8
29700 C***************
29800 IF(L.EQ.1)GO TO 95
29900 C BEAM LFT=1, RT=2 (PARAM 8=10 OR 20)
30000 R2Q=RD
30100 RJX=RJY+HGT
30200 GO TO 94
30300 C**************
30400 8 R2Q=RH
30500 RA=RD
30600 RJY=RJX-HGT
30700 RJX=RJX-HGT1
30800 GO TO 94
30900 95 RA=RD
31000 RJY=RJX-HGT
31100 94 RC=0
31200 CXX L=8
31300 CC IF(RMINI.LT..65)L=3
31400 CXX IF(RMINI.LT.1.)L=7.*RMINI
31450 L=8.*RMINI
31500 C MINI LINES HAVE .2 SMALLER BEAMS. MAYBE CHANGE THIS??
31600 CALL LINES(R2Q,RJX,3)
31700 DO 941 K=1,L
31800 CALL BMS
31900 IF(PLT.GE.0)GO TO 940
32000 CC RC=RC+1
32100 RC=RC+RY
32200 C FOR THICKENING.
32300 CALL BMS
32400 CALL EXCH(RA,R2Q)
32500 941 CALL EXCH(RJY,RJX)
32600 CALL BMS
32700 C DRAWS 5 LINES FOR BEAMS.
32800 940 JJ2=JJ2-1
32900 IF(JJ2.LE.0)RETURN
33000 C IF P7=10 OR 20 ONE BEAM WILL APPEAR.
33100 RJY=RJY+RJ
33200 RJX=RJX+RJ
33300 GO TO 93
33400
33500 100 RA=0
33600 C FOR STAFF LINES: 10, POS 1, HGT(3 TO -3), 2ND POS., UP-DOWN(NT #S)
33700 C P6=SIZE FACTOR, IF P7≠0 STAFF IS INVIS.
33800 CC J3=J3+4
33900 IF(R6.EQ.0)R6=RSTFAC(J3)
34000 CALL NOZERO(R6)
34100 RSTFAC(J3)=R6
34200 RX=(J3+3)*123-369.+R5*7.*R6
34250 STFF(J3)=RX
34300 IF(J7.EQ.0)GO TO 101
34400 IF(PLT.EQ.0)CALL LINES(-596.,RX,3)
34500 C TO ACTIVATE DPY BUFFER
34600 RETURN
34700 101 RX=RX+RTF*R6
34800 C FOR RTF SEE DATA
34900 C FOR 2 PASS PLOTTING
35000 CC R2=RHORZ(R2)
35100 CC RJ=RHORZ(FLOAT(J4))
35200 CC IF(J4.EQ.0)RJ=596
35220 RJ=RHORZ(R4)
35240 IF(R4.EQ.0)RJ=596
35300 R6=R6*14.
35400 DO 6 K=1,5
35500 RZ=RJ
35600 RW=R2
35700 IF(K.EQ.2.OR.K.EQ.4)CALL EXCH(RW,RZ)
35800 CALL LINX(RZ,RX,RW,RX)
35900 6 RX=RX+R6
36000 END
36100
36200 SUBROUTINE BMS
36300 COMMON/STF/RSTFAC(-3/4),RSTJ3/BM/RA,RC,RJY
36400 CALL LINES(RA,RJY+RC*RSTJ3,2)
36500 END
36600
36700 SUBROUTINE METER
36800 COMMON R2,JA,CENTR,J2,RJQ(20),JQ(20)/STF/RSTFAC(-3/4),RSTJ3
36900 EQUIVALENCE (R4,RJQ(2)),(R7,RJQ(5)),(R6,RJQ(4)),(R5,RJQ(3))
37000
37100 C PARAMS 18 / POS / STF / TOP NUM/ BOT NUM/ VERT.HGT/ SIZE FAC.
37200
37300 JZ=J2
37400 RY=R6+8.
37500 C HEIGHT
37600 RW=R5
37700 C BOTTOM NUM
37800 R6=R4
37900 C TOP NUM
38000 R5=R7
38100 C SIZE
38200 C FOR BDR40 -- OR =1
38300 M=0
38400 R4=RY
38500 2 R7=0
38600 CC JA=5
38700 IF(R6.GE.10.)J2=J2+4.*RSTJ3
38800 C TO CENTER 12S AND 16S
38900 CALL MAKNUM(R6)
39000 IF(M)RETURN
39100 C STICK AROUND FOR BOTTOM NUM
39200 M=-1
39300 R4=RY-4.
39400 R6=RW
39500 C GET BOTTOM NUM
39600 J2=JZ
39700 GO TO 2
39800 END
39900
40000 SUBROUTINE RNOTE(X)
40100 COMMON /PTR/PWDS(250),ITEM,L,I,IX/XRN/RN(4000)
40200 X=RN(IFIX(PWDS(IFIX(AMOD(X,1000.))))+2)
40300 END
40400
40500 SUBROUTINE MAKNUM(RNUM)
40600 COMMON R2,JA,CENTR,J2,RJQ(20),JQ(20)/STF/RSTFAC(-3/4),RSTJ3
40700 EQUIVALENCE (J3,JQ(1)),(R4,RJQ(2)),(R8,RJQ(6)),(R7,RJQ(5))
40800 1,(R6,RJQ(4)),(R5,RJQ(3)),(R7,RJQ(5)),(JQ(15),B),(JQ(16),C)
40900 DATA RS/9.0/
41000 J2X=J2
41100 C P7=0=BDR40; =1=BDI40; =2=PRIM.
41200 J3=J2-RS*RSTJ3
41300 C FOR 2 DIGIT NUMBER
41400 CALL NOZERO(R5)
41500 CC2 R6=485000.00
41600 C UPPER CASE - BDR40
41700 CC IF(R7.EQ.2)R6=485100.00
41800 R6=480000.00+(R7+50.)*100.
41900 C P7=2 = BDI40 - ITALIC NUMS.
42000 R7=999999.99
42100 C BLANKS
42200 R8=R7
42300 IF(RNUM.GT.9.)GO TO 3
42400 C JUMP FOR 2 DIGIT NUMBER
42500 R6=R6+RNUM+.47
42600 C PUTS BLANK ON END (.47)
42700 GO TO 1
42800
42900 3 B=IFIX(RNUM/10.)
43000 C=AMOD(RNUM,10.)
43100 R6=R6+B+C/100.
43200 J2=J3
43300 1 CALL ALPHA
43400 J2=J2X
43500 C RETURNS ORIG. HORIZ. POS.
43600 END
43700 C MAKES ONLY 1 AND 2 DIGIT NUMS NOW. EXPAND LATER.